home *** CD-ROM | disk | FTP | other *** search
/ Light ROM 1 / LIGHT-ROM 1 (Amiga Library Services)(1994).iso / ffdisks / d963.lha / SIOD / scm / bi-ar.s < prev    next >
Text File  |  1993-10-01  |  9KB  |  187 lines
  1. (define archivio-environment
  2.         (make-environment
  3.         (define (binsearch archivio elem last ord-test eq-test)
  4.             (let ((first 0))
  5.                  (do ((mid (quotient (+ first last) 2)
  6.                            (quotient (+ first last) 2)))
  7.                      ((or (>= mid last)
  8.                           (<= mid first)
  9.                           (eq-test elem (vector-ref archivio mid)))
  10.                       (if (eq-test elem (vector-ref archivio mid))
  11.                           (do ()
  12.                               ((or (= mid 0)
  13.                                    (not (eq-test elem
  14.                                                  (vector-ref archivio
  15.                                                              (-1+ mid)))))
  16.                                 mid)
  17.                                (set! mid (-1+ mid)))
  18.                           'not-found))
  19.                      (if (ord-test (vector-ref archivio mid) elem)
  20.                          (set! first mid)
  21.                          (set! last mid)))))
  22.         (define (interchange archivio i j)
  23.                 (define tmp (vector-ref archivio i))
  24.                 (vector-set! archivio i (vector-ref archivio j))
  25.                 (vector-set! archivio j tmp))
  26.         (define (qsort archivio m n ord-test)
  27.                 (if (< m n)
  28.                     (do ((i m)
  29.                          (j (1+ n))
  30.                          (k (begin (interchange archivio
  31.                                                 m
  32.                                                 (quotient (+ m n)
  33.                                                           2))
  34.                                    (vector-ref archivio m))))
  35.                         ((>= i j) (interchange archivio m j)
  36.                                   (qsort archivio m (-1+ j) ord-test)
  37.                                   (qsort archivio (1+ j) n ord-test))
  38.                         (set! i (1+ i))
  39.                         (do ()
  40.                             ((or (ord-test k (vector-ref archivio i))
  41.                                  (>= i n)))
  42.                             (set! i (1+ i)))
  43.                         (set! j (-1+ j))
  44.                         (do ()
  45.                             ((or (ord-test (vector-ref archivio j) k)
  46.                                  (<= j m)))
  47.                             (set! j (-1+ j)))
  48.                         (if (< i j)
  49.                             (interchange archivio i j)))))
  50.         (define (delete-el! archivio index last)
  51.                 (do ()
  52.                     ((= last index))
  53.                     (vector-set! archivio
  54.                                  index
  55.                                  (vector-ref archivio (1+ index)))
  56.                     (set! index (1+ index))))
  57.         (define (ar-for-each archivio fun last)
  58.                 (do ((i 0 (1+ i)))
  59.                     ((= i last))
  60.                     (fun (vector-ref archivio i))))
  61.         (define (insert-el! archivio y last ord-test)
  62.                 (do ()
  63.                     ((or (= last 0)
  64.                          (ord-test (vector-ref archivio (-1+ last)) y))
  65.                     (vector-set! archivio last y))
  66.                     (vector-set! archivio
  67.                                  last
  68.                                  (vector-ref archivio (-1+ last)))
  69.                     (set! last (-1+ last))))
  70.         (define (load-ar nome)
  71.                 (define port nil)
  72.                 (define res nil)
  73.                 (if (file-exists? nome)
  74.                     (begin (set! port (open-input-file nome))
  75.                            (if (eq? (read port) 'archivio-v1.0)
  76.                                (begin (set! res (cons (read port) res))
  77.                                       (set! res (cons (read port) res))
  78.                                       (set! res (cons (read port) res))
  79.                                       (set! res (cons (read port) res))
  80.                                       (close-input-port port)
  81.                                 res)
  82.                            (begin (close-input-port port)
  83.                            'not-archive-v1.0)))
  84.                     'not-found))
  85.         (define (save-ar archivio last nome user-data order)
  86.                 (define port (open-output-file nome))
  87.                 (print 'archivio-v1.0 port)
  88.                 (print archivio port)
  89.                 (print last port)
  90.                 (print user-data port)
  91.                 (print order port)
  92.                 (close-output-port port))
  93.         (define (make-dispatcher size o-test e-test user-data)
  94.             (define archivio (make-vector (1+ size) nil))
  95.             (define order #t)
  96.             (define last-el 0)
  97.             (define nome "arch.dat")
  98.             (define (dispatch message value)
  99.                 (cond ((eq? message 'save)
  100.                        (if (string? value)
  101.                            (set! nome value))
  102.                        (save-ar archivio last-el nome user-data order))
  103.                       ((eq? message 'load)
  104.                         (let ((r (load-ar value)))
  105.                              (if (pair? r)
  106.                                  (begin (set! archivio (cadddr r))
  107.                                         (set! last-el (caddr r))
  108.                                         (set! user-data (cadr r))
  109.                                         (set! order (car r))
  110.                                         (set! nome value)
  111.                                         (set! size
  112.                                               (-1+ (vector-length archivio)))
  113.                                         'done)
  114.                                   r)))
  115.                        ((eq? message 'add-ord)
  116.                            (if (< last-el size)
  117.                                (begin (if order
  118.                                           (begin (insert-el! archivio
  119.                                                              value
  120.                                                              last-el
  121.                                                              o-test)
  122.                                                  (set! last-el
  123.                                                        (1+ last-el))
  124.                                                  'done)
  125.                                           'not-in-order))
  126.                                'full))
  127.                        ((eq? message 'del-el)
  128.                            (if (and (< value last-el) (>= value 0))
  129.                                (begin (delete-el! archivio value last-el)
  130.                                (set! last-el (-1+ last-el))
  131.                                'done)
  132.                                'out-of-range))
  133.                        ((eq? message 'for-each)
  134.                            (ar-for-each archivio value last-el)
  135.                            'done)
  136.                        ((eq? message 'last-el)
  137.                            last-el)
  138.                        ((eq? message 'us-data)
  139.                            user-data)
  140.                        ((eq? message 'order)
  141.                            order)
  142.                        ((eq? message 'ch-us-da)
  143.                            (set! user-data value)
  144.                            'done)
  145.                        ((eq? message 'sort)
  146.                            (if (or (not order) value)
  147.                                (begin (qsort archivio
  148.                                              0
  149.                                              (-1+ last-el)
  150.                                              o-test)
  151.                                       (set! order #t)))
  152.                            'done)
  153.                        ((eq? message 'add)
  154.                            (if (< last-el size)
  155.                                (begin (vector-set! archivio
  156.                                                    last-el
  157.                                                    value)
  158.                                       (set! last-el (1+ last-el))
  159.                                       (set! order #f)
  160.                                       'done)
  161.                                'full))
  162.                        ((eq? message 'ch-ord)
  163.                            (set! o-test (car value))
  164.                            (set! e-test (cdr value))
  165.                            'done)
  166.                        ((eq? message 'read)
  167.                            (if (and (< value last-el) (>= value 0))
  168.                                (vector-ref archivio value)
  169.                                'out-of-range))
  170.                        ((eq? message 'search)
  171.                            (if order
  172.                                (binsearch archivio
  173.                                           value
  174.                                           last-el
  175.                                           o-test
  176.                                           e-test)
  177.                                'not-in-order))
  178.                        (else 'unknown-message)))
  179.                 dispatch)))
  180. (define (make-archivio size ord-test eq-test user-data)
  181.         (eval (list 'make-dispatcher
  182.                     size
  183.                     ord-test
  184.                     eq-test
  185.                     (list 'quote user-data))
  186.               archivio-environment))
  187.